home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr01 / halcn305.zip / GSOB_DBF.PAS < prev    next >
Pascal/Delphi Source File  |  1993-07-25  |  34KB  |  1,108 lines
  1. unit GSOB_DBF;
  2. {-----------------------------------------------------------------------------
  3.                           dBase III/IV File Handler
  4.  
  5.        GSOB_DBF Copyright (c)  Richard F. Griffin
  6.  
  7.        03 August 1992
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit handles the object for all dBase III/IV file (.DBF)
  14.        operations.  The object to manipulate the fields in the
  15.        records of a dBase file is also contained here.
  16.  
  17.                    SHAREWARE  -- COMMERCIAL USE RESTRICTED
  18.  
  19.    Changes:
  20.  
  21.       02 May 93 - Routines used for conversion to/from numbers have been
  22.                   modified to be of type FloatNum.  This allows numbers to
  23.                   have up to 20 significant digits.  Note that the $N+ and
  24.                   $E+ switches must be set (Alt O,C,8,E in IDE) to compile
  25.                   using this feature.  Otherwise, 11-12 digits will be used.
  26.                   The use of the $N+,E+ switch adds 10K to program size.
  27.  
  28.                   When you compile a program in the $N+,E+ state, the
  29.                   compiler links with the full 80x87 emulator.  The resulting
  30.                   .EXE file can be run on any machine, regardless of whether
  31.                   that machine has an 80x87. If an 80x87 is present, the
  32.                   program will use it; otherwise, the run-time library
  33.                   emulates it.  This gives you access to four additional
  34.                   real types: Single, Double, Extended, and Comp.  The $E+
  35.                   directive will emulate the 80x87. This gives you access
  36.                   to the IEEE floating-point types without requiring that you
  37.                   install an 80x87 chip.
  38.  
  39.       02 May 93 - Corrected Append to Write the header in order to update
  40.                   the record count.
  41.  
  42.       15 Jul 93 - In GetRec, removed the call to RecsInFile.  This doubled
  43.                   the speed of sequential reads.  Now, End-Of-File condition
  44.                   is determined by the contents of dfGoodRec--if it is not
  45.                   equal to RecLen, then File_EOF is set.
  46.  
  47. ------------------------------------------------------------------------------}
  48. interface
  49.  
  50. uses
  51.      GSOB_Var,
  52.      GSOB_Dte,
  53.      GSOB_Dsk,    {File handler}
  54.      GSOB_Str,    {String handling Routines}
  55.      {$IFDEF WINDOWS}
  56.         WinDOS,
  57.         Objects;     {Collection handler}
  58.      {$ELSE}
  59.         DOS,
  60.         GSOB_Obj;
  61.      {$ENDIF}
  62.  
  63. const
  64.  
  65.    UseDelRecord : boolean = true;      {True if deleted records are used}
  66.    dbExactMatch : boolean = false;
  67.  
  68. type
  69.  
  70.    dbFileStatus = (Invalid, NotOpen, NotUpdated, Updated);
  71.  
  72.    GSP_DBFHeader = ^GSR_DBFHeader;
  73.    GSR_DBFHeader = Record
  74.       DBType     : Byte;
  75.       Year       : Byte;
  76.       Month      : Byte;
  77.       Day        : Byte;
  78.       RecCount   : LongInt;
  79.       Location   : Integer;
  80.       RecordLen  : Integer;
  81.       Reserved   : Array[1..20] of Byte;
  82.    end;
  83.  
  84.    GSP_DBFField = ^GSR_DBFField;
  85.    GSR_DBFField = Record
  86.       FieldName    : array[0..10] of char;
  87.       FieldType    : Char;
  88.       FieldAddress : pointer;
  89.       FieldLen     : Byte;
  90.       FieldDec     : Byte;
  91.       FieldNum     : Integer;          {Used by GS to hold the field number}
  92.       Reserved     : Array[1..12] of Char;
  93.    end;
  94.  
  95.    GSP_FieldArray = ^GSA_FieldArray;
  96.    GSA_FieldArray  = ARRAY[1..512] OF GSR_DBFField;
  97.  
  98.    GSP_dBaseDBF = ^GSO_dBaseDBF;
  99.    GSO_dBaseDBF = object(GSO_DiskFile)
  100.       HeadProlog   : GSR_DBFHeader;   {Image of file header}
  101.       dStatus      : dbFileStatus;    {Holds Status Code of file}
  102.       NumRecs      : LongInt;         {Number of records in file}
  103.       HeadLen      : Integer;         {Header + Field Descriptor length}
  104.       RecLen       : Integer;         {Length of record}
  105.       NumFields    : Integer;         {Number of fields in the record}
  106.       DelFlag      : boolean;         {True if record deleted}
  107.       Fields       : GSP_FieldArray;  {Pointer to memory array holding}
  108.                                       {field descriptors}
  109.       RecNumber    : LongInt;         {Physical record number last read}
  110.       CurRecord    : PByteArray;      {Pointer to memory array holding}
  111.                                       {the current record data.  Refer}
  112.                                       {to Appendix B for record structure}
  113.       File_EOF     : boolean;         {True if access tried beyond end of file}
  114.       File_TOF     : boolean;         {True if access tried before record 1}
  115.       FileVers     : byte;
  116.       FileIsLocked : boolean;
  117.       LockCount    : word;
  118.       CONSTRUCTOR Init(FName : string);
  119.       DESTRUCTOR  Done; virtual;
  120.       PROCEDURE   Append; virtual;
  121.       PROCEDURE   Close; virtual;
  122.       Procedure   Flush; virtual;
  123.       PROCEDURE   GetRec(RecNum: LongInt); virtual;
  124.       Procedure   HdrWrite; virtual;
  125.       Function    LokApnd: boolean; virtual;
  126.       Function    LokFile: boolean; virtual;
  127.       Function    LokIt(fposn,flgth: longint): boolean;
  128.       Procedure   LokOff; virtual;
  129.       Function    LokRcrd: boolean; virtual;
  130.       PROCEDURE   Open; virtual;
  131.       PROCEDURE   PutRec(RecNum : LongInt); virtual;
  132.       Function    RecsInFile: Longint; virtual;
  133.       Procedure   Replace; virtual;
  134.    end;
  135.  
  136.    GSP_dBaseFld = ^GSO_dBaseFld;
  137.    GSO_dBaseFld = object(GSO_dBaseDBF)
  138.       WithMemo     : boolean;         {True if memo file present}
  139.       FieldPtr     : GSP_DBFField;
  140.       Constructor  Init(FName : string);
  141.       Function     AnalyzeField(var fldst: string) : GSP_DBFField; virtual;
  142.       Procedure    Blank; virtual;
  143.       Function     CheckField(var st : string; ftyp : char) : GSP_DBFField;
  144.       Function     DateGet(st : string) : longint; virtual;
  145.       Function     DateGetN(n : integer) : longint; virtual;
  146.       Procedure    DatePut(st : string; jdte : longint); virtual;
  147.       Procedure    DatePutN(n : integer; jdte : longint); virtual;
  148.       Procedure    Delete; virtual;
  149.       Function     FieldGet(fnam : string) : string; virtual;
  150.       Function     FieldGetN(fnum : integer) : string; virtual;
  151.       Procedure    FieldPut(fnam, st : string); virtual;
  152.       Procedure    FieldPutN(fnum : integer; st : string); virtual;
  153.       Function     FieldDecimals(i : integer) : integer; virtual;
  154.       Function     FieldLength(i : integer) : integer; virtual;
  155.       Function     FieldName(i : integer) : string; virtual;
  156.       Function     FieldType(i : integer) : char; virtual;
  157.       Procedure    GetRec(RecNum: LongInt); virtual;
  158.       Function     LogicGet(st : string) : boolean; virtual;
  159.       Function     LogicGetN(n : integer) : boolean; virtual;
  160.       Procedure    LogicPut(st : string; b : boolean); virtual;
  161.       Procedure    LogicPutN(n : integer; b : boolean); virtual;
  162.       Function     NumberGet(st : string) : FloatNum; virtual;
  163.       Function     NumberGetN(n : integer) : FloatNum; virtual;
  164.       Procedure    NumberPut(st : string; r : FloatNum); virtual;
  165.       Procedure    NumberPutN(n : integer; r : FloatNum); virtual;
  166.       Function     StringGet(fnam : string) : string; virtual;
  167.       Function     StringGetN(fnum : integer) : string; virtual;
  168.       Procedure    StringPut(fnam, st : string); virtual;
  169.       Procedure    StringPutN(fnum : integer; st : string); virtual;
  170.       Procedure    Undelete; virtual;
  171.    end;
  172.  
  173.  
  174.    GSP_DBFBuild = ^GSO_DBFBuild;
  175.    GSO_DBFBuild = object(TCollection)
  176.       dbTypeNoMo  : byte;
  177.       dbTypeMemo  : byte;
  178.       dFile       : GSP_DiskFile;
  179.       mFile       : GSP_DiskFile;
  180.       HeadRec     : GSR_DBFHeader;
  181.       FileName    : string;
  182.       hasMemo     : boolean;
  183.       dbRecLen    : integer;
  184.       dbTitle     : string[8];
  185.       Constructor Init(FName : string);
  186.       Destructor  Done; virtual;
  187.       Procedure   InsertField(s : string; t : char; l,d : integer); virtual;
  188.       Procedure   WriteDBF; virtual;
  189.       Procedure   WriteDBT; virtual;
  190.    end;
  191.  
  192.    GSP_DB3Build = ^GSO_DB3Build;
  193.    GSO_DB3Build = GSO_DBFBuild;
  194.  
  195.    GSP_DB4Build = ^GSO_DB4Build;
  196.    GSO_DB4Build = object(GSO_DBFBuild)
  197.       Constructor Init(FName : string);
  198.       Procedure   WriteDBT; virtual;
  199.    end;
  200.  
  201. Procedure SetCentury(tf: boolean);
  202. Procedure SetDateType(dt : DateCountry);
  203. Procedure SetDeleted(tf: boolean);
  204. Procedure SetExact(tf: boolean);
  205.  
  206.  
  207. {------------------------------------------------------------------------------
  208.                             IMPLEMENTATION SECTION
  209. ------------------------------------------------------------------------------}
  210.  
  211. implementation
  212.  
  213. const
  214.    EohMark      : Byte = $0D;          {Byte stored at end of the header}
  215.    AccessTries  : word = 1000;         {Attempts to access file before stop}
  216.  
  217. {-----------------------------------------------------------------------------
  218.                               Global Functions
  219. -----------------------------------------------------------------------------}
  220.  
  221. PROCEDURE SetCentury(tf: boolean);
  222. BEGIN
  223.    GS_Date_Century := tf;
  224. END;
  225.  
  226. Procedure SetDateType(dt : DateCountry);
  227. BEGIN
  228.    GS_Date_Type := dt;
  229. END;
  230.  
  231. PROCEDURE SetDeleted(tf: boolean);
  232. BEGIN
  233.    UseDelRecord := not tf;
  234. END;
  235.  
  236. PROCEDURE SetExact(tf: boolean);
  237. BEGIN
  238.    dbExactMatch := tf;
  239. END;
  240.  
  241. {------------------------------------------------------------------------------
  242.                                 GSO_dBaseDBF
  243. ------------------------------------------------------------------------------}
  244.  
  245.  
  246. CONSTRUCTOR GSO_dBaseDBF.Init(FName : string);
  247. VAR
  248.    fl : integer;                   {field length working variable}
  249.  
  250.    Function ProcessHeader: boolean;
  251.    BEGIN             {ProcessHeader}
  252.       GSO_DiskFile.Read(0, HeadProlog, 32);
  253.       CASE HeadProlog.DBType OF        {test for valid dBase types}
  254.          DB3File,
  255.          DB3WithMemo,
  256.          DB4File,
  257.          DB4WithMemo,
  258.          FXPWithMemo : begin                            {Good File}
  259.                           FileVers := HeadProlog.DBType;
  260.                           HeadLen := HeadProlog.Location;  {length of header}
  261.                           RecLen := HeadProlog.RecordLen;  {Length of record}
  262.                        end;
  263.          ELSE
  264.          BEGIN
  265.             FileVers := 0;       {If not a valid dBase file, stop}
  266.             Error(gsBadDBFHeader,dbfInitError);
  267.          END;
  268.       END;                      {CASE}
  269.       ProcessHeader := FileVers <> 0;
  270.    END;                      {ProcessHeader}
  271.  
  272. begin
  273.    GSO_DiskFile.Init(FName+'.DBF',dfReadWrite+dfSharedDenyNone);
  274.    if dfFileExst then
  275.    begin
  276.       Reset(1);                       {File length of one byte}
  277.       if not ProcessHeader then exit; {Load file structure information}
  278.       NumRecs := RecsInFile;          {Get record counr}
  279.       RecNumber := 0;                 {Set current record to zero}
  280.       File_EOF := false;              {Set End of File flag to false}
  281.       File_TOF := false;              {Set Top of File flag to false};
  282.       fl := HeadLen-33;               {Size of field descriptors}
  283.       GetMem(Fields, fl);             {Allocate memory for fields buffer.}
  284.       NumFields := fl div 32;         {Number of fields}
  285.       GSO_DiskFile.Read(-1, Fields^, fl);          {Store field data}
  286.       GSO_DiskFile.Close;             {Finished with file for now}
  287.       GetMem(CurRecord, RecLen+1);    {Allocate memory for record buffer}
  288.       CurRecord^[RecLen] := EofMark;  {End of file flag after record}
  289.       FileIsLocked := false;
  290.       LockCount := 0;
  291.       dStatus := NotOpen;             {Set file status to 'Not Open'   }
  292.    end
  293.    else
  294.    begin
  295.       dStatus := Invalid;
  296.       Error(dosFileNotFound,dbfInitError);    {Error -- No such file}
  297.       CurRecord := nil;
  298.       Fields := nil;
  299.    end;
  300. end;
  301.  
  302. Destructor GSO_dBaseDBF.Done;
  303. begin
  304.    GSO_dBaseDBF.Close;              {Close the file before finishing up}
  305.    if CurRecord <> nil then FreeMem(CurRecord, RecLen+1);
  306.                                     {DeAllocate memory for record buffer}
  307.    if Fields <> nil then FreeMem(Fields, HeadLen-33);
  308.                                     {DeAllocate memory for fields buffer.}
  309.    GSO_DiskFile.Done;
  310. end;
  311.  
  312. PROCEDURE GSO_dBaseDBF.Append;
  313. VAR
  314.    icr : word;
  315.    b1A : word;
  316.    FSz : longint;
  317. BEGIN
  318.    icr := 0;
  319.    if GS_AutoShare then
  320.    begin
  321.       repeat inc(icr) until LokApnd or (icr > AccessTries);  {Append Lock}
  322.       if icr > AccessTries then
  323.       begin                                    {If not successful....}
  324.          Error(dosAccessDenied,dbfAppendError);
  325.          exit;
  326.       end;
  327.    end;
  328.    dStatus := Updated;             {Set file status to 'Updated'}
  329.  
  330.    FSz := FileSize;
  331.    FSz := (FileSize-HeadLen);
  332.    b1A := FSz mod RecLen;
  333.  
  334.    AddToFile(CurRecord^, RecLen+1, b1A);      {Append}
  335.    LokOff;
  336.    RecNumber := NumRecs+1;           {Store record number as current record }
  337.    HdrWrite;
  338. END;
  339.  
  340. PROCEDURE GSO_dBaseDBF.Close;
  341. begin
  342.    IF dStatus = NotOpen THEN exit;     {Exit if file not open}
  343.    IF dStatus = Updated THEN HdrWrite; {Write new header information if the}
  344.                                        {file was updated in any way}
  345.    GSO_DiskFile.Close;                 {Go close file}
  346.    dStatus := NotOpen;                 {Set objectname.dStatus to 'NotOpen'}
  347. END;                        { GS_dBase_Close }
  348.  
  349. Procedure GSO_dBaseDBF.Flush;
  350. var
  351.    holdflush : dfFlushStatus;
  352. begin
  353.    holdflush := dfFileFlsh;        {turn off flush temporarily to avoid}
  354.    dfFileFlsh := NeverFlush;       {an endless loop if WriteFlush, as the}
  355.    HdrWrite;                       {header write would call Flush again}
  356.    dfFileFlsh := holdflush;
  357.    GSO_DiskFile.Flush;
  358. end;
  359.  
  360. PROCEDURE GSO_dBaseDBF.GetRec(RecNum : LongInt);
  361. VAR
  362.    RNum   : LongInt;                  {Local working variable  }
  363. BEGIN
  364.    if NumRecs = 0 then
  365.    begin
  366.       File_EOF := true;
  367.       File_TOF := true;
  368.       exit;
  369.    end;
  370.    RNum := RecNum;                    {Store RecNum locally for modification}
  371.    File_EOF := false;                 {Initialize End of File Flag to false}
  372.    File_TOF := false;
  373.    case RNum of
  374.       Next_Record : RNum := RecNumber + 1;   {Advance one record}
  375.       Prev_Record : begin
  376.                        RNum := RecNumber - 1;   {Back up one record}
  377.                        if RNum = 0 then
  378.                        begin
  379.                           RNum := 1;
  380.                           File_TOF := true;
  381.                           Exit;
  382.                        end;
  383.                     end;
  384.       Top_Record  : RNum := 1;               {Set to the first record}
  385.       Bttm_Record : begin
  386.                        NumRecs := RecsInFile;   {Set to the last record}
  387.                        RNum := NumRecs;
  388.                     end;
  389.       else
  390.          if (RNum < 1) then
  391.          begin
  392.             Error(gsDBFRangeError,dbfGetRecError);
  393.             exit;
  394.          end
  395.          else
  396.          begin
  397.             if (RNum > NumRecs) then
  398.             begin
  399.                NumRecs := RecsInFile;    {Confirm set to the last record}
  400.                if (RNum > NumRecs) then  {Still out of range?}
  401.                begin
  402.                   File_EOF := true;
  403.                   exit;
  404.                end;
  405.             end;
  406.          end;
  407.    end;
  408.    Read(HeadLen+((RNum-1) * RecLen), CurRecord^, RecLen);
  409.                                       {Read RecLen bytes into memory buffer}
  410.                                       {for the correct physical record}
  411.    if dfGoodRec < RecLen then
  412.    begin
  413.       File_EOF := true;
  414.       exit;
  415.    end;
  416.    RecNumber := RNum;                 {Set objectname.RecNumber = this record }
  417.    if CurRecord^[0] = GS_dBase_DltChr then DelFlag := true
  418.       else DelFlag := false;
  419. END;                  {GetRec}
  420.  
  421. Procedure GSO_dBaseDBF.HdrWrite;
  422. var
  423.    rsl : word;
  424.    icr : word;
  425.    yy, mm, dd, wd : word;     {Local variables to get today's date}
  426. begin
  427.    if dfFileShrd and not FileIsLocked then
  428.    begin
  429.       icr := 0;
  430.       repeat
  431.          rsl := GS_LockFile(dfFileHndl,0,8);
  432.          inc(icr);
  433.       until (rsl = 0) or (icr > AccessTries);
  434.       if rsl <>  0 then
  435.       begin
  436.          Error(dosAccessDenied, dbfHdrWriteError);
  437.          exit;
  438.       end;
  439.    end;
  440.    GetDate (yy,mm,dd,wd);          {Call TP's GetDate procedure}
  441.    HeadProlog.year := yy-1900;     {Extract the Year}
  442.    HeadProlog.month := mm;         {Extract the Month}
  443.    HeadProlog.day := dd;           {Extract the Day}
  444.    NumRecs := RecsInFile;
  445.    HeadProlog.RecCount := NumRecs; {Update number records in file}
  446.    Write(0, HeadProlog, 8);
  447.    if dfFileShrd and not FileIsLocked then
  448.       rsl := GS_UnLockFile(dfFileHndl,0,8);
  449.    dStatus := NotUpdated;          {Reset updated status}
  450. end;
  451.  
  452. Function GSO_dBaseDBF.LokApnd: boolean;
  453. begin
  454.    LokApnd := LokIt(FileSize+dfDirtyRead, RecLen+1);
  455. end;
  456.  
  457. Function GSO_dBaseDBF.LokFile: boolean;
  458. begin
  459.    FileIsLocked := LokIt(dfDirtyRead, dfDirtyRead-1); {Lock all possible filesize}
  460.    LokFile := FileIsLocked;
  461. end;
  462.  
  463. Function GSO_dBaseDBF.LokIt(fposn,flgth: longint): boolean;
  464. var
  465.    rsl : word;
  466. begin
  467.    if dfFileShrd then
  468.    begin
  469.       if not dfLockRec then LockCount := 0;
  470.       if FileIsLocked then rsl := 0
  471.          else rsl := LockRec(fposn,flgth);
  472.       if rsl = 0 then inc(LockCount);
  473.       LokIt := rsl = 0;
  474.    end
  475.    else LokIt := true;
  476. end;
  477.  
  478. Function GSO_dBaseDBF.LokRcrd: boolean;
  479. begin
  480.    LokRcrd := LokIt((HeadLen+((RecNumber-1)*RecLen))+dfDirtyRead,RecLen);
  481. end;
  482.  
  483. Procedure GSO_dBaseDBF.LokOff;
  484. var
  485.    rsl : word;
  486. begin
  487.    if not dfLockRec then
  488.    begin
  489.       LockCount := 0;
  490.       exit;
  491.    end;
  492.    dec(LockCount);
  493.    if LockCount > 0 then exit;   {Could have stacked locks if programmer}
  494.    rsl := Unlock;                {and automatic locking.  Only unlock   }
  495.                                  {when stack cleared.                   }
  496.    if (dfFileFlsh = UnlockFlush) then HdrWrite;
  497.    FileIsLocked := false;
  498. end;
  499.  
  500. PROCEDURE GSO_dBaseDBF.Open;
  501. BEGIN              { GS_dBase_Open }
  502.    if dStatus = NotOpen then          {Do only if file not already open}
  503.    begin
  504.       Reset(1);                       {Open .DBF file}
  505.       dStatus := NotUpdated;          {Set status to 'Not Updated' }
  506.       RecNumber := 0;                 {Set current record to zero }
  507.       LockCount := 0;
  508.    end;
  509. END;               { GS_dBase_Open }
  510.  
  511. PROCEDURE GSO_dBaseDBF.PutRec(RecNum : LongInt);
  512. VAR
  513.    Result : Word;                     {Local Variable}
  514.    RNum   : LongInt;                  {Local Variable}
  515.    HNum   : Longint;
  516.    icr    : word;
  517. BEGIN
  518.    RNum := RecNum;
  519.    IF (RNum > NumRecs) or (RNum < 1) then Append
  520.    else
  521.    begin
  522.       HNum := RecNumber;
  523.       RecNumber := RNum;
  524.       icr := 0;
  525.       if GS_AutoShare then
  526.       begin
  527.          repeat inc(icr) until LokRcrd or (icr > AccessTries);  {Record Lock}
  528.          if icr > AccessTries then
  529.          begin                                    {If not successful....}
  530.             Error(dosAccessDenied,dbfPutRecError);
  531.             RecNumber := HNum;
  532.             exit;
  533.          end;
  534.       end;
  535.       dStatus := Updated;            {Set file status to 'Updated'}
  536.       Write(HeadLen+((RNum-1)*RecLen), CurRecord^, RecLen);
  537.       LokOff;
  538.    end;
  539. END;                        {PutRec}
  540.  
  541. Function GSO_dBaseDBF.RecsInFile: Longint;
  542. begin
  543.    RecsInFile := (FileSize-HeadLen) div RecLen;
  544. end;
  545.  
  546. Procedure GSO_dBaseDBF.Replace;
  547. begin
  548.    PutRec(RecNumber);
  549. end;
  550.  
  551. {------------------------------------------------------------------------------
  552.                           GSO_dBaseFld Working Routines
  553. ------------------------------------------------------------------------------}
  554.  
  555. Function FieldLocate(fdsc: GSP_FieldArray; st: string; var i: integer):boolean;
  556. var
  557.    mtch : boolean;
  558.    ix   : integer;
  559.    za   : string[16];
  560. begin
  561.    st := TrimR(AllCaps(st));
  562.    ix := i;
  563.    i := 1;
  564.    mtch := false;
  565.    while (i <= ix) and not mtch do
  566.    begin
  567.       CnvAscToStr(GSR_DBFField(fdsc^[i]).FieldName,za,11);
  568.       if za = st then mtch := true else inc(i);
  569.    end;
  570.    FieldLocate := mtch;
  571. end;
  572.  
  573. Function FieldPull(fr: GSP_DBFField) : string;
  574. var
  575.    s : string;
  576. begin
  577.    with fr^ do
  578.    begin
  579.       move(FieldAddress^,s[1], FieldLen);
  580.       s[0] := chr(FieldLen);
  581.       FieldPull := s;
  582.    end;
  583. end;
  584.  
  585. Procedure FieldPush(fr: GSP_DBFField; st : string);
  586. begin
  587.    with fr^ do
  588.    begin
  589.       if FieldType in ['C','L','D'] then st := PadR(st,FieldLen)
  590.          else st := PadL(st,FieldLen);
  591.       move(st[1],FieldAddress^,FieldLen);
  592.    end;
  593. end;
  594.  
  595. Function StringPull(fr: GSP_DBFField) : string;
  596. var
  597.    s : string;
  598.    d : longint;
  599. begin
  600.    with fr^ do
  601.    begin
  602.       move(FieldAddress^,s[1],FieldLen);
  603.       s[0] := chr(FieldLen);
  604.       s := TrimR(s);
  605.       case FieldType of
  606.          'D' : begin
  607.                   d := ValDate(s);
  608.                   if d > 0 then s := StrDate(d)
  609.                   else
  610.                   begin
  611.                      s :=  '00/00/00';
  612.                      if GS_Date_Century then s := s + '00';
  613.                   end;
  614.                end;
  615.          'L' : s := StrLogic(ValLogic(s));
  616.          'M' : begin
  617.                   s := TrimL(s);
  618.                   if s > '0' then  s := '---MEMO---' else s := '---memo---';
  619.                end;
  620.          'F',
  621.          'N' : s := TrimL(s);
  622.       end;
  623.    end;
  624.    StringPull := s;
  625. end;
  626.  
  627. Procedure StringPush(fr: GSP_DBFField; st : string);
  628. var
  629.    d : longint;
  630. begin
  631.    if fr^.FieldType = 'D' then
  632.       st := GS_Date_dBStor(GS_Date_Juln(st));
  633.    FieldPush(fr, st);
  634. end;
  635.  
  636. {------------------------------------------------------------------------------
  637.                                 GSO_dBaseFld
  638. ------------------------------------------------------------------------------}
  639.  
  640. constructor GSO_dBaseFld.Init(FName : string);
  641. var
  642.    i   : integer;
  643.    offset : integer;
  644. begin
  645.    GSO_dBaseDBF.Init(FName);
  646.    offset := 1;
  647.    for i := 1 to NumFields do
  648.    begin
  649.       Fields^[i].FieldNum := i;
  650.       Fields^[i].FieldAddress := @CurRecord^[offset];
  651.       offset := offset + Fields^[i].FieldLen;
  652.    end;
  653.    Case FileVers of
  654.       DB3WithMemo,
  655.       DB4WithMemo,
  656.       FXPWithMemo : WithMemo := true;
  657.       else WithMemo := false;
  658.    end;
  659.    DelFlag := false;
  660. end;
  661.  
  662. function GSO_dBaseFld.AnalyzeField(var fldst : string) : GSP_DBFField;
  663. var
  664. LastFieldCk : integer;
  665. begin
  666.    LastFieldCk := NumFields;
  667.    if FieldLocate(Fields,fldst,LastFieldCk) then
  668.       AnalyzeField := @Fields^[LastFieldCk]
  669.    else
  670.       AnalyzeField := nil;
  671. end;
  672.  
  673. procedure GSO_dBaseFld.Blank;
  674. begin
  675.    FillChar(CurRecord^[0], RecLen, ' '); {Fill spaces for RecLen bytes}
  676. end;
  677.  
  678. function  GSO_dBaseFld.CheckField(var st: string; ftyp: char): GSP_DBFField;
  679. var
  680.    FPtr : GSP_DBFField;
  681. begin
  682.    FPtr := AnalyzeField(st);
  683.    if FPtr = nil then
  684.       Error(gsInvalidField,dbfCheckFieldError)
  685.    else if FPtr^.FieldType <> ftyp then
  686.       Error(gsBadFieldType,dbfCheckFieldError);
  687.    CheckField := FPtr;
  688. end;
  689.  
  690. function  GSO_dBaseFld.DateGet(st : string) : longint;
  691. var
  692.    v : longint;
  693. begin
  694.    FieldPtr := CheckField(st,'D');
  695.    v := 0;
  696.    if (FieldPtr <> nil) then
  697.       v := ValDate(FieldPull(FieldPtr));
  698.    DateGet := v;
  699. end;
  700.  
  701. function  GSO_dBaseFld.DateGetN(n : integer) : longint;
  702. var
  703.    v : longint;
  704. begin
  705.    if (n > NumFields) or (n < 1) then v := 0
  706.    else
  707.    begin
  708.       FieldPtr := @Fields^[n];
  709.       v := ValDate(FieldPull(FieldPtr));
  710.    end;
  711.    DateGetN := v;
  712. end;
  713.  
  714. Procedure GSO_dBaseFld.DatePut(st : string; jdte : longint);
  715. begin
  716.    FieldPtr := CheckField(st,'D');
  717.    if (FieldPtr <> nil) then
  718.        FieldPush(FieldPtr,GS_Date_dBStor(jdte));
  719. end;
  720.  
  721. Procedure GSO_dBaseFld.DatePutN(n : integer; jdte : longint);
  722. begin
  723.    if (n > NumFields) or (n < 1) then exit;
  724.    FieldPtr := @Fields^[n];
  725.    FieldPush(FieldPtr,GS_Date_dBStor(jdte));
  726. end;
  727.  
  728. Procedure GSO_dBaseFld.Delete;
  729. begin
  730.    DelFlag := true;                   {Set Delete Flag to true}
  731.    CurRecord^[0] := GS_dBase_DltChr;  {Put '*' in first byte of current record}
  732.    GSO_dBaseDBF.PutRec(RecNumber);    {Write the current record to disk }
  733. end;                 {GS_dBase_Delete}
  734.  
  735. Function GSO_dBaseFld.FieldGet(fnam : string) : string;
  736. begin
  737.    FieldPtr := AnalyzeField(fnam);
  738.    if (FieldPtr <> nil)  then
  739.       FieldGet := FieldPull(FieldPtr)
  740.          else FieldGet := '';
  741. end;
  742.  
  743. Function GSO_dBaseFld.FieldGetN(fnum : integer) : string;
  744. begin
  745.    if (fnum > NumFields) or (fnum < 1) then
  746.    begin
  747.       FieldGetN := '';
  748.       exit;
  749.    end;
  750.    FieldPtr := @Fields^[fnum];
  751.    FieldGetN := FieldPull(FieldPtr);
  752. end;
  753.  
  754. Procedure GSO_dBaseFld.FieldPut(fnam, st : string);
  755. begin
  756.    FieldPtr := AnalyzeField(fnam);
  757.    if (FieldPtr <> nil)  then
  758.       FieldPush(FieldPtr,st);
  759. end;
  760.  
  761. Procedure GSO_dBaseFld.FieldPutN(fnum : integer; st : string);
  762. begin
  763.    if (fnum > NumFields) or (fnum < 1) then exit;
  764.    FieldPtr := @Fields^[fnum];
  765.    FieldPush(FieldPtr,st);
  766. end;
  767.  
  768. function GSO_dBaseFld.FieldDecimals(i : integer) : integer;
  769. begin
  770.    if (i > NumFields) or (i < 1) then
  771.    begin
  772.       FieldDecimals := 0;
  773.       exit;
  774.    end;
  775.    FieldPtr := @Fields^[i];
  776.    FieldDecimals := FieldPtr^.FieldDec;
  777. end;
  778.  
  779. function GSO_dBaseFld.FieldLength(i : integer) : integer;
  780. begin
  781.    if (i > NumFields) or (i < 1) then
  782.    begin
  783.       FieldLength := 0;
  784.       exit;
  785.    end;
  786.    FieldPtr := @Fields^[i];
  787.    FieldLength := FieldPtr^.FieldLen;
  788. end;
  789.  
  790. function GSO_dBaseFld.FieldName(i : integer) : string;
  791. var
  792.    st : string[16];
  793.    p  : integer;
  794. begin
  795.    if (i > NumFields) or (i < 1) then
  796.    begin
  797.       FieldName := '';
  798.       exit;
  799.    end;
  800.    FieldPtr := @Fields^[i];
  801.    move(FieldPtr^.FieldName,st[1],10);
  802.    st[0] := #10;
  803.    p := pos(#0,st);
  804.    if p > 0 then st[0] := chr(p-1);
  805.    FieldName := st;
  806. end;
  807.  
  808. function GSO_dBaseFld.FieldType(i : integer) : char;
  809. begin
  810.    if (i > NumFields) or (i < 1) then
  811.    begin
  812.       FieldType := #0;
  813.       exit;
  814.    end;
  815.    FieldPtr := @Fields^[i];
  816.    FieldType := FieldPtr^.FieldType;
  817. end;
  818.  
  819. PROCEDURE GSO_dBaseFld.GetRec(RecNum : LongInt);
  820. VAR
  821.    RNum   : LongInt;                  {Local working variable  }
  822. BEGIN
  823.    GSO_dBaseDBF.GetRec(RecNum);
  824.    if RecNum > 0 then exit;     {done if physical record access}
  825.    if DelFlag and (not UseDelRecord) then
  826.    begin
  827.       RNum := RecNumber;
  828.       while DelFlag and (not (File_EOF or File_TOF)) do
  829.       begin
  830.          case RecNum of
  831.             Top_Record,
  832.             Next_Record : inc(RNum);
  833.             Bttm_Record,
  834.             Prev_Record : dec(RNum);
  835.          end;
  836.          if RNum < 1 then File_TOF := true
  837.             else if RNum > NumRecs then File_EOF := true
  838.                else GSO_dBaseDBF.GetRec(RNum);
  839.       end;
  840.    end;
  841. end;
  842.  
  843. function  GSO_dBaseFld.LogicGet(st : string) : boolean;
  844. var
  845.    v : boolean;
  846. begin
  847.    FieldPtr := CheckField(st,'L');
  848.    v := false;
  849.    if (FieldPtr <> nil) then
  850.       v := ValLogic(FieldPull(FieldPtr));
  851.    LogicGet := v;
  852. end;
  853.  
  854. function  GSO_dBaseFld.LogicGetN(n : integer) : boolean;
  855. var
  856.    v : boolean;
  857. begin
  858.    if (n > NumFields) or (n < 1) then v := false
  859.    else
  860.    begin
  861.       FieldPtr := @Fields^[n];
  862.       v := ValLogic(FieldPull(FieldPtr));
  863.    end;
  864.    LogicGetN := v;
  865. end;
  866.  
  867. Procedure GSO_dBaseFld.LogicPut(st : string; b : boolean);
  868. begin
  869.    FieldPtr := CheckField(st,'L');
  870.    if (FieldPtr <> nil)  then
  871.       FieldPush(FieldPtr,StrLogic(b));
  872. end;
  873.  
  874. Procedure GSO_dBaseFld.LogicPutN(n : integer; b : boolean);
  875. begin
  876.    if (n > NumFields) or (n < 1) then exit;
  877.    FieldPtr := @Fields^[n];
  878.    FieldPush(FieldPtr,StrLogic(b));
  879. end;
  880.  
  881. function GSO_dBaseFld.NumberGet(st : string) : FloatNum;
  882. var
  883.    v : FloatNum;
  884. begin
  885.    FieldPtr := CheckField(st,'N');
  886.    v := 0;
  887.    if (FieldPtr <> nil) then
  888.       v := ValNumber(FieldPull(FieldPtr));
  889.    NumberGet := v;
  890. end;
  891.  
  892. function  GSO_dBaseFld.NumberGetN(n : integer) : FloatNum;
  893. var
  894.    v : FloatNum;
  895. begin
  896.    if (n > NumFields) or (n < 1) then v := 0
  897.    else
  898.    begin
  899.       FieldPtr := @Fields^[n];
  900.       v := ValNumber(FieldPull(FieldPtr));
  901.    end;
  902.    NumberGetN := v;
  903. end;
  904.  
  905. Procedure GSO_dBaseFld.NumberPut(st : string; r : FloatNum);
  906. begin
  907.    FieldPtr := CheckField(st,'N');
  908.    if (FieldPtr <> nil)  then
  909.       FieldPush(FieldPtr,StrNumber(r,FieldPtr^.FieldLen,FieldPtr^.FieldDec));
  910. end;
  911.  
  912. Procedure GSO_dBaseFld.NumberPutN(n : integer; r : FloatNum);
  913. begin
  914.    if (n > NumFields) or (n < 1) then exit;
  915.    FieldPtr := @Fields^[n];
  916.    FieldPush(FieldPtr,StrNumber(r,FieldPtr^.FieldLen,FieldPtr^.FieldDec));
  917. end;
  918.  
  919. Function GSO_dBaseFld.StringGet(fnam : string) : string;
  920. begin
  921.    FieldPtr := AnalyzeField(fnam);
  922.    if (FieldPtr <> nil)  then
  923.       StringGet := StringPull(FieldPtr)
  924.          else StringGet := '';
  925. end;
  926.  
  927. Function GSO_dBaseFld.StringGetN(fnum : integer) : string;
  928. begin
  929.    if (fnum > NumFields) or (fnum < 1) then
  930.    begin
  931.       StringGetN := '';
  932.       exit;
  933.    end;
  934.    FieldPtr := @Fields^[fnum];
  935.    StringGetN := StringPull(FieldPtr);
  936. end;
  937.  
  938. Procedure GSO_dBaseFld.StringPut(fnam, st : string);
  939. begin
  940.    FieldPtr := AnalyzeField(fnam);
  941.    if (FieldPtr <> nil)  then
  942.       StringPush(FieldPtr,st);
  943. end;
  944.  
  945. Procedure GSO_dBaseFld.StringPutN(fnum : integer; st : string);
  946. begin
  947.    if (fnum > NumFields) or (fnum < 1) then exit;
  948.    FieldPtr := @Fields^[fnum];
  949.    StringPush(FieldPtr,st);
  950. end;
  951.  
  952. Procedure GSO_dBaseFld.UnDelete;
  953. begin
  954.    DelFlag := false;                  {Set Delete flag to false}
  955.    CurRecord^[0] := GS_dBase_UnDltChr;
  956.                                       {Put ' ' in first byte of current record}
  957.    GSO_dBaseDBF.PutRec(RecNumber);                 {Write the current record to disk }
  958. end;
  959.  
  960. {-----------------------------------------------------------------------------
  961.                             GSO_DBFBuild
  962. -----------------------------------------------------------------------------}
  963.  
  964. Constructor GSO_DBFBuild.Init(FName : string);
  965. var
  966.    i,j : integer;
  967. begin
  968.    TCollection.Init(32,32);
  969.    hasMemo := false;
  970.    dbTypeNoMo := DB3File;
  971.    dbTypeMemo := DB3WithMemo;
  972.    Filename := AllCaps(FName);
  973.    dbRecLen := 1;
  974.    i := length(FileName);
  975.    j := i;
  976.    while (i > 0) and not (FileName[i] in ['\',':']) do
  977.    begin
  978.       if FileName[i] = '.' then j := i-1;
  979.       i := i-1;
  980.    end;
  981.    i := i+1;
  982.    dbTitle := copy(FileName,i,(j-i)+1);
  983. end;
  984.  
  985. Destructor GSO_DBFBuild.Done;
  986. var
  987.    i : integer;
  988.    f : GSP_DBFField;
  989. begin
  990.    dFile := New(GSP_DiskFile, Init(FileName+'.DBF',dfReadWrite));
  991.    dFile^.Rewrite(1);
  992.    WriteDBF;
  993.    Dispose(dFile, Done);
  994.    if HasMemo then WriteDBT;
  995.    for i := 0 to Count-1 do
  996.    begin
  997.       f := at(i);
  998.       dispose(f);
  999.    end;
  1000.    DeleteAll;
  1001.    TCollection.Done;
  1002. end;
  1003.  
  1004. procedure GSO_DBFBuild.InsertField(s : string; t : char; l,d : integer);
  1005. var
  1006.    f : GSP_DBFField;
  1007. begin
  1008.    New(f);
  1009.    s := AllCaps(s);
  1010.    CnvStrToAsc(s,f^.FieldName,11);
  1011.    f^.FieldType := upcase(t);
  1012.    case f^.FieldType of
  1013.       'D' : begin
  1014.                l := 8;
  1015.                d := 0;
  1016.             end;
  1017.       'L' : begin
  1018.                l := 1;
  1019.                d := 0;
  1020.             end;
  1021.       'M' : begin
  1022.                l := 10;
  1023.                d := 0;
  1024.                hasMemo := true;
  1025.             end;
  1026.    end;
  1027.    f^.FieldLen := l;
  1028.    f^.FieldDec := d;
  1029.    f^.FieldAddress := nil;
  1030.    f^.FieldNum := 0;
  1031.    FillChar(f^.Reserved,12,#0);
  1032.    if f^.FieldType = 'M' then hasMemo := true;
  1033.    dbRecLen := dbRecLen + l;
  1034.    Insert(f);
  1035. end;
  1036.  
  1037. Procedure GSO_DBFBuild.WriteDBF;
  1038. var
  1039.    i : integer;
  1040.    yy, mm, dd, wd : word;             {Variables to hold GetDate values}
  1041.  
  1042. BEGIN
  1043.    if hasMemo then HeadRec.DBType := dbTypeMemo
  1044.       else HeadRec.DBType := dbTypeNoMo;
  1045.    GetDate (yy,mm,dd,wd);
  1046.    HeadRec.year := yy-1900; {Year}
  1047.    HeadRec.month := mm; {Month}
  1048.    HeadRec.day := dd; {Day}
  1049.    HeadRec.RecCount := 0;
  1050.    HeadRec.Location := (Count*32) + 33;
  1051.    HeadRec.RecordLen := dbRecLen;
  1052.    FillChar(HeadRec.Reserved,20,#0);
  1053.    dFile^.Write(0, HeadRec, 32);
  1054.    for i := 0 to Count-1 do
  1055.       dFile^.Write(-1, Items^[i]^, 32);
  1056.    dFile^.Write(-1, EohMark, 1);            {Put EOH marker }
  1057.    dFile^.Write(-1, EofMark, 1);            {Put EOF marker }
  1058. END;
  1059.  
  1060. Procedure GSO_DBFBuild.WriteDBT;
  1061. var
  1062.    buf : array[0..31] of byte;
  1063.    i : integer;
  1064. begin
  1065.    FillChar(buf,32,#0);
  1066.    buf[0] := $01;
  1067.    move(dbTitle[1],buf[8],length(dbTitle));
  1068.    mFile := New(GSP_DiskFile, Init(FileName+'.DBT',dfReadWrite));
  1069.    mFile^.Rewrite(1);
  1070.    mFile^.Write(0, buf, 32);
  1071.    FillChar(buf,32,#0);
  1072.    for i := 1 to 15 do mFile^.Write(-1, buf, 32);
  1073.    mFile^.Write(-1, EofMark, 1);
  1074.    Dispose(mFile, Done);
  1075. end;
  1076.  
  1077. {-----------------------------------------------------------------------------
  1078.                                 GSO_DB4Build
  1079. -----------------------------------------------------------------------------}
  1080.  
  1081. Constructor GSO_DB4Build.Init(FName : string);
  1082. begin
  1083.    GSO_DBFBuild.Init(FName);
  1084.    dbTypeNoMo := DB4File;
  1085.    dbTypeMemo := DB4WithMemo;
  1086. end;
  1087.  
  1088. Procedure GSO_DB4Build.WriteDBT;
  1089. var
  1090.    buf : array[0..31] of byte;
  1091. begin
  1092.    FillChar(buf,32,#0);
  1093.    buf[0] := $01;
  1094.    move(dbTitle[1],buf[8],length(dbTitle));
  1095.    buf[18] := $02;
  1096.    buf[19] := $01;
  1097.    buf[21] := $02;
  1098.    mFile := New(GSP_DiskFile, Init(FileName+'.DBT',dfReadWrite));
  1099.    mFile^.Rewrite(1);
  1100.    mFile^.Write(0, buf, 24);
  1101.    Dispose(mFile, Done);
  1102. end;
  1103.  
  1104.  
  1105. end.
  1106. {-----------------------------------------------------------------------------}
  1107.                                       END
  1108.